Developer CD Series 1996 February: Tool Chest/Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso/Tool Chest/Development Tools & Languages/Dylan Related/Marlais/MacMarlais 0.5.9d46/AppleEvent stuff/tc-send.el

Text File | 1994-11-29 | 14.1 KB | 426 lines | [TEXT/EMAC]

;;;
;;; Code to send Apple events to Think C
;;;

(defmacro create-marlais-apple-event (eventClass eventID event transactionID)
  (list 'ae-create-apple-event "Mrls" eventClass eventID event transactionID))

(defun marlais:send-event (event)
  (let* ((reply (make-string sizeof-AppleEvent 0))
     (err (AESend event reply (+ kAEQueueReply kAENeverInteract)
              kAENormalPriority 0 0 0)))
    (if (not (zerop err))
    err
      reply)))

(defun marlais:open-file (file)
  (let* (event
     (reply (make-string sizeof-AppleEvent 0))
     spec
     transactionID
     (result
      (catch 'panic
        (throw-err (create-marlais-apple-event kCoreEventClass kAEOpenDocuments
                           event transactionID))
        (throw-err (unix-filename-to-FSSpec file spec))
        (throw-err (AEPutParamPtr event keyDirectObject typeFSS spec (length spec)))
        (throw-err (AESend event reply (+ kAENoReply kAENeverInteract)
                   kAENormalPriority 0 0 0))
        noErr)))
    (if event (AEDisposeDesc event))
    result))

(defun marlais:extract-result (reply)
  (let* ((result-type (make-string (c:sizeof 'long) 0))
     (result-size (make-string (c:sizeof 'long) 0))
     (err (AESizeOfParam event keyDirectObject result-type result-size)))
    (if (not (zerop err))
    ""
      (let* ((actual-size (extract-internal result-size 0 'long))
         (str (make-string actual-size 0))
         (err (AEGetParamPtr event keyDirectObject typeChar
                 result-type str actual-size result-size)))
    str))))

;; the handler that gets called when the queued reply is received.

(defun marlais:do-eval-reply (event history)
  (let* ((error-number-data (make-string 4 0))
     (returnedType (make-string 4 0))
     (actualSize (make-string 4 0))
     (err (AEGetParamPtr event keyErrorNumber typeLongInteger returnedType
                 error-number-data (length error-number-data) actualSize)))
    (if (= err errAEDescNotFound)
    (let* ((result-type (make-string (c:sizeof 'long) 0))
           (result-size (make-string (c:sizeof 'long) 0))
           (err (AESizeOfParam event keyDirectObject result-type result-size)))
      (if (not (zerop err))
          err
        (let* ((actual-size (extract-internal result-size 0 'long))
           (s (make-string actual-size 0))
           (err (AEGetParamPtr event keyDirectObject typeChar
                       result-type s actual-size result-size)))
          (if (not (zerop err))
          err
        (save-excursion
          (insert-reply s)
          noErr))))
      (tc:think-ref-announce-error history error-number-data)
      noErr))))

(defun marlais:eval (expr)
  (let* (event
     (reply (make-string sizeof-AppleEvent 0))
     transactionID
     (result
      (catch 'panic
        (throw-err (create-marlais-apple-event kAEMiscStandards kAEDoScript
                           event transactionID))
        (throw-err (AEPutParamPtr event keyDirectObject typeChar expr (length expr)))
        (throw-err (AESend event reply (+ kAEQueueReply kAEAlwaysInteract)
                   kAENormalPriority 0 0 0))
        noErr)))
    ;; store information so our AppleEvent reply can find its way back to us.
    (setq ae-history (cons (cons transactionID
                 (list (cons 'description "marlais:eval")
                       (cons 'handler 'marlais:do-eval-reply)))
               ae-history))
    (if event (AEDisposeDesc event))
    (if reply (AEDisposeDesc reply))
    result))

;; example calls to MacMarlais

;;(marlais:eval "get-file();")
;;(marlais:eval "1 + 2;")
;;(marlais:eval "beep();")
;;(marlais:open-file "~/.emacs")

;;; stuff below is around cause we looked at how THINK-C support works.

;;; Used when sending kRun events
(defvar tc:use-debugger nil)

;;; Used when sending kMake events
(defvar tc:quick-scan t "*When nil, turn off quick scan for Make.")

(defmacro create-think-c-apple-event (eventClass eventID event transactionID)
  (list 'ae-create-apple-event "KAHL" eventClass eventID event transactionID))

(defun tc:send-event (event)
  (let* ((reply (make-string sizeof-AppleEvent 0))
     (err (AESend event reply (+ kAEQueueReply kAENeverInteract)
              kAENormalPriority 0 0 0)))
    (if (not (zerop err))
    err
      reply)))

(defun tc:open-file (file)
  (let* (event
     (reply (make-string sizeof-AppleEvent 0))
     spec
     transactionID
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kCoreEventClass kAEOpenDocuments
                           event transactionID))
        (throw-err (unix-filename-to-FSSpec file spec))
        (throw-err (AEPutParamPtr event keyDirectObject typeFSS spec (length spec)))
        (throw-err (AESend event reply (+ kAENoReply kAENeverInteract)
                   kAENormalPriority 0 0 0))
        noErr)))
    (if event (AEDisposeDesc event))
    result))

(defun tc:run ()
  (let* (event
     (reply (make-string sizeof-AppleEvent 0))
     transactionID
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kAEThinkSuite kAERun
                           event transactionID))
        (throw-err (AEPutParamPtr event keyUpdateOptions typeEnumerated kAEYes 4))
        (throw-err (AEPutParamPtr event keyAESaveOptions typeEnumerated kAEYes 4))
        (throw-err (AEPutParamPtr event keyUseDebugger typeBoolean
                      (make-string 1 (if tc:use-debugger 1 0)) 1))
        (throw-err (AEPutParamPtr event keyGo typeBoolean (make-string 1 1) 1))
        (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
                   kAENormalPriority 0 0 0))
        (setq ae-history (cons (cons transactionID
                     (list (cons 'description "run")
                           (cons 'handler 'do-simple-reply)))
                   ae-history))
        noErr)))

    (if event (AEDisposeDesc event))
    result))

(defun tc:open-project (file)
  (let* (event
     spec
     (reply (make-string sizeof-AppleEvent 0))
     actualSize
     transactionID
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kCoreEventClass kAEOpen
                           event transactionID))
        (throw-err (unix-filename-to-FSSpec file spec))
        (throw-err (AEPutParamPtr event keyDirectObject typeFSS spec (length spec)))
        (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
                   kAENormalPriority 0 0 0))
        (setq ae-history
          (cons (cons transactionID
                  (list (cons 'description (concat "open-project " file))
                    (cons 'handler 'do-simple-reply)))
            ae-history))
        noErr)))

    (if event (AEDisposeDesc event))
    result))

(defun tc:close-project ()
  (let* ((null-desc (make-string sizeof-AEDesc 0))
     have-null-desc
     (proj-desc (make-string sizeof-AEDesc 0))
     have-proj-desc
     (proj-obj (make-string sizeof-AEDesc 0))
     have-proj-obj
     event
     (reply (make-string sizeof-AppleEvent 0))
     actualSize
     transactionID
     (one (encode-long-integer 1))
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kCoreEventClass kAEClose
                           event transactionID))
        (throw-err (AECreateDesc typeNull "" 0 null-desc))
        (setq have-null-desc t)
        (throw-err (AECreateDesc typeLongInteger one (length one) proj-desc))
        (setq have-proj-desc t)
        (throw-err (CreateObjSpecifier cProjectDocument null-desc formAbsolutePosition
                       proj-desc 0 proj-obj))
        (setq have-proj-obj t)
        (throw-err (AEPutParamDesc event keyDirectObject proj-obj))

        (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
                   kAENormalPriority 0 0 0))

        (setq ae-history
          (cons (cons transactionID (list (cons 'description "close-project")
                          (cons 'handler 'do-simple-reply)))
            ae-history))
        noErr)))

    (if have-null-desc (AEDisposeDesc null-desc))
    (if have-proj-desc (AEDisposeDesc proj-desc))
    (if have-proj-obj (AEDisposeDesc proj-obj))
    (if event (AEDisposeDesc event))
    result))

(defun tc:build-application (appname)
  (let* ((null-desc (make-string sizeof-AEDesc 0))
     have-null-desc
     (proj-obj (make-string sizeof-AEDesc 0))
     have-proj-obj
     (proj-desc (make-string sizeof-AEDesc 0))
     have-proj-desc
     event
     (reply (make-string sizeof-AppleEvent 0))
     actualSize
     transactionID
     spec
     (one (encode-long-integer 1))
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kAECoreSuite kAESave
                           event transactionID))

        (throw-err (AECreateDesc typeNull "" 0 null-desc))
        (setq have-null-desc t)
        (throw-err (AECreateDesc typeLongInteger one (length one) proj-desc))
        (setq have-proj-desc t)
        (throw-err (CreateObjSpecifier cProjectDocument null-desc formAbsolutePosition
                       proj-desc 0 proj-obj))
        (setq have-proj-obj t)
        (throw-err (AEPutParamDesc event keyDirectObject proj-obj))

        (let ((err (unix-filename-to-FSSpec appname spec)))
          (if (and (not (zerop err)) (not (= err fnfErr))) (throw 'panic err)))
        (throw-err (AEPutParamPtr event keyAEFile typeFSS spec (length spec)))
        (throw-err (AEPutParamPtr event keyAEFileType typeType kProjectType 4))
        (throw-err (AEPutParamPtr event keySaveFlags typeLongInteger one (length one)))

        (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
                   kAENormalPriority 0 0 0))

        (setq ae-history
          (cons (cons transactionID
                  (list (cons 'description (concat "build-application " appname))
                    (cons 'handler 'tc:do-build-reply)))
            ae-history))
        noErr)))

    (if have-null-desc (AEDisposeDesc null-desc))
    (if have-proj-desc (AEDisposeDesc proj-desc))
    (if have-proj-obj (AEDisposeDesc proj-obj))
    (if event (AEDisposeDesc event))
    result))

(defun tc:make ()
  (let* ((null-desc (make-string sizeof-AEDesc 0))
     have-null-desc
     (file-desc (make-string sizeof-AEDesc 0))
     have-file-desc
     (file-obj (make-string sizeof-AEDesc 0))
     have-file-obj
     (reply (make-string sizeof-AppleEvent 0))
     event
     resultType
     transactionID
     actualSize
     (flags (encode-long-integer (+ (if tc:quick-scan 2 0) 4)))
     (one (encode-long-integer 1))
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kAEThinkSuite kMake
                           event transactionID))

        (throw-err (AECreateDesc typeNull "" 0 null-desc))
        (setq have-null-desc t)
        (throw-err (AECreateDesc typeLongInteger one (length one) file-desc))
        (setq have-file-desc t)
        (throw-err (CreateObjSpecifier cProjectDocument null-desc formAbsolutePosition
                       file-desc 0 file-obj))
        (setq have-file-obj t)
        (throw-err (AEPutParamDesc event keyDirectObject file-obj))
        (throw-err (AEPutParamPtr event keyCompileFlags typeLongInteger
                      flags (length flags)))

        (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
                   kAENormalPriority 0 0 0))

        (setq ae-history (cons (cons transactionID
                     (list (cons 'description "make")
                           (cons 'handler 'tc:do-compile-reply)
                           (cons 'flavor kMake)))
                   ae-history))
        noErr)))

    (if have-null-desc (AEDisposeDesc null-desc))
    (if have-file-desc (AEDisposeDesc file-desc))
    (if have-file-obj (AEDisposeDesc file-obj))
    (if event (AEDisposeDesc event))
    result))

(defun tc:compile-file-internal (file operation)
  (let* ((null-desc (make-string sizeof-AEDesc 0))
     have-null-desc
     (file-desc (make-string sizeof-AEDesc 0))
     have-file-desc
     (file-obj (make-string sizeof-AEDesc 0))
     have-file-obj
     reply
     event
     resultType
     transactionID
     actualSize
     (flags (encode-long-integer 32))
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kAEThinkSuite operation
                           event transactionID))

        (throw-err (AECreateDesc typeNull "" 0 null-desc))
        (setq have-null-desc t)
        (throw-err (AECreateDesc typeChar file (length file) file-desc))
        (setq have-file-desc t)
        (throw-err (CreateObjSpecifier cSourceFile null-desc formName
                       file-desc 0 file-obj))
        (setq have-file-obj t)
        (throw-err (AEPutParamDesc event keyDirectObject file-obj))

        (if (or (equal operation kDisassemble)
            (equal operation kPreprocess))
        (throw-err
         (AEPutParamPtr event keyCompileFlags typeLongInteger flags (length flags))))

        (setq reply (tc:send-event event))
        (if (integerp reply) (throw 'panic reply))
        (setq ae-history
          (cons (cons transactionID
                  (list
                   (cons 'description
                     (concat
                      (cdr (assoc operation
                          (list (cons kCompile "compile")
                            (cons kCheckSyntax "check-syntax")
                            (cons kPreprocess "preprocess")
                            (cons kDisassemble "disassemble"))))
                      " " file))
                   (cons 'handler 'tc:do-compile-reply)
                   (cons 'flavor operation)))
            ae-history))
        (tc:launch-tpm) ;;; We'll bring TPM to the front here.
        noErr)))

    (if have-null-desc (AEDisposeDesc null-desc))
    (if have-file-desc (AEDisposeDesc file-desc))
    (if have-file-obj (AEDisposeDesc file-obj))
    (if event (AEDisposeDesc event))
    result))

(defun tc:compile-file (filename)
  (tc:compile-file-internal filename kCompile))

(defun tc:check-syntax (filename)
  (tc:compile-file-internal filename kCheckSyntax))

(defun tc:disassemble (filename)
  (tc:compile-file-internal filename kDisassemble))

(defun tc:preprocess (filename)
  (tc:compile-file-internal filename kPreprocess))

(defun tc:remove-objects ()
  (let* (event
     (null-desc (make-string sizeof-AEDesc 0))
     have-null-desc
     (objcode-desc (make-string sizeof-AEDesc 0))
     have-objcode-desc
     (objcode-obj (make-string sizeof-AEDesc 0))
     have-object-obj
     (reply (make-string sizeof-AppleEvent 0))
     actualSize
     transactionID
     (one (encode-long-integer 1))
     (result
      (catch 'panic
        (throw-err (create-think-c-apple-event kAECoreSuite kAEDelete
                           event transactionID))
        (throw-err (AECreateDesc typeNull "" 0 null-desc))
        (setq have-null-desc t)
        (throw-err (AECreateDesc typeLongInteger one (length one) objcode-desc))
        (setq have-objcode-desc t)
        (throw-err (CreateObjSpecifier cObjectCode null-desc formAbsolutePosition
                       objcode-desc 0 objcode-obj))
        (setq have-objcode-obj t)
        (throw-err (AEPutParamDesc event keyDirectObject objcode-obj))

        (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
                   kAENormalPriority 0 0 0))

        (setq ae-history (cons (cons transactionID
                     (list (cons 'description "remove-objects")
                           (cons 'handler 'do-simple-reply)))
                   ae-history))
        noErr)))

    (if event (AEDisposeDesc event))
    (if have-objcode-desc (AEDisposeDesc objcode-desc))
    (if have-objcode-obj (AEDisposeDesc objcode-obj))
    (if have-null-desc (AEDisposeDesc null-desc))
    result))